package CGI::FOGE2::Test;
# $Id: Test.pm,v 1.1 2004/02/21 18:48:08 ibo Exp $

our @ISA = ();

use HTML::TokeParser;

sub new {
    # title-string, logfile-filehandle ->
    my $proto = shift;
    my $class = ref($proto) || $proto;
    my $self  = {};

    my ($testname, $flog) = @_;

    $self->{nbtotal}   = 0;
    $self->{nbfail}    = 0;
    $self->{nbsuccess} = 0;
    $self->{testname} = $testname;
    $self->{subtestname} = undef;
    $self->{flog} = $flog;

    printf "\n-------- test: %s --------\n", $self->{testname};

    # from perlfaq5 - autoflush on STDOUT
    select((select(STDOUT), $| = 1)[0]);

    bless ($self, $class);
    return $self;
}

sub testname {
    # string ->
    # Makes the object remembers the name of the current test

    my $self = shift;
    my ($name) = @_;
    $self->{subtestname} = $name;
    ++$self->{nbtotal};

    printf " %4d: %-32s ", 
	$self->{nbtotal},
        $self->{subtestname};
}

sub testresult {
    # bool, bool ->
    # testresult(is_success, fatal) remembers the result (is_success == true)
    # of the current test. If the test failed and fatal == true, the 
    # sequence of tests is aborted (i.e. the script dies). 

    my $self = shift;
    my ($success, $isfatal) = @_;
    my $flog = $self->{flog};

    if ($success) {
        ++$self->{nbsuccess};
        print "ok";
    } else {
        ++$self->{nbfail};
        print "FAILED";
	printf $flog "failed subtest: %s: %s\n", 
	    $self->{testname}, $self->{subtestname};
    }

    if ($isfatal && !$success) {
        print " (fatal)\n";
        $self->die();
    } else {
        print "\n";
    }
}

# normal termination
sub finish{
    # ->
    # this method must be called at the end of a test case

    # The script terminates with exit status 0 if all tests were successful, 
    # 1 otherwise. A summary is also printed to STDOUT. 

    my $self = shift;
    my $isok = ($self->{nbtotal} == $self->{nbsuccess});
    $self->terminate($isok?0:1);
}

# private (?)
sub die {
    # "fatal error" termination
    my $self = shift;
    $self->terminate(1);
}

# private
sub terminate {
    my $self = shift;
    my $exit_status = shift;

    printf "Test %-26s [%d/%d] (%.2f%%)\n",
      '`'.$self->{testname}.'\':', 
        $self->{nbsuccess}, $self->{nbtotal},
        100 * $self->{nbsuccess} / $self->{nbtotal};
    my $flog = $self->{flog};
    printf $flog "!Summary!%s!%d!%d\n", 
	$self->{testname},
	$self->{nbsuccess},
	$self->{nbtotal};

    exit $exit_status;
}

sub html_to_array {
  # HTML::TokeParser htp -> ref to array of array of string

  # When calling, htp's pointer must be on a <table> tag
  # When this method returns, htp's pointer is after the table
    my $self = shift;
    my $htp = shift;

    my @table = ();
    my @ligne = ();
    my $state = 0;

    # automaton to parse the HTML table
    my $tok;
    while ($state != 2 && ($tok = $htp->get_token())) {
      if ($state == 0) {
	if ($tok->[0] eq "S" && $tok->[1] eq "tr") {
	  $state = 1;
	}
      } elsif ($state == 1) {
	if ($tok->[0] eq "E" && $tok->[1] eq "table") {
	  $state = 2;
	} elsif ($tok->[0] eq "S" && $tok->[1] eq 'td') {
	  my $text = $htp->get_trimmed_text('/td');
	  push @ligne, $text;
	} elsif ($tok->[0] eq "S" && $tok->[1] eq 'th') {
	  my $text = $htp->get_trimmed_text('/th');
	  push @ligne, $text;
	} elsif ($tok->[0] eq "E" && $tok->[1] eq "tr") {
	  my @locline;
	  foreach my $elem (@ligne) {
	    push @locline, $elem;
	  }
	  push @table, \@locline;
	  @ligne = ();
	}
      }
    }

    return \@table;
}

# perl 2D table -> string representation
sub table_to_string {
  my $self = shift;
  my ($t, $out, $i) = (shift, '', 0);

  foreach my $e (@$t) {
    $out .= sprintf "%d => [%s] ", $i++ , (join ', ', @$e);
  }
  return sprintf "[%s]", $out;
}

# value, value, tolerance: approximate equality test
sub eqtol {
  my $self = shift;
  my ($v0, $v1, $tol) = @_;

  return abs($v1-$v0) <= $tol;
}

1;
